;;; -*- Mode:LISP; Package:TV; Base:8; Lowercase:T; Readtable:ZL -*-
;;;     ** (c) Copyright 1980 Massachusetts Institute of Technology **

;;;This is overridden by loading SYS:WINDOW;RH, which is now standardly loaded.
(DEFVAR STREAM-MIXIN-DEFAULT-RUBOUT-HANDLER 'DEFAULT-RUBOUT-HANDLER
  "Default rubout-handler to use for input from windows")

;;; Io stream stuff
(DEFFLAVOR STREAM-MIXIN
           (;; I/O buffer for this stream
            (IO-BUFFER NIL)
            (RUBOUT-HANDLER-BUFFER NIL)
            ;; Used for :PREEMPTABLE-READ.
            (OLD-TYPEAHEAD NIL)
            ;; nil => use stream-mixin-default-rubout-handler
            (stream-rubout-handler)
            (displayer nil)
            stream-spare-1
            stream-spare-2
            stream-spare-3
            stream-spare-4
            stream-spare-5
            stream-spare-6)
           ()
  (:REQUIRED-FLAVORS SHEET ESSENTIAL-WINDOW)    ;Explicit presence of SHEET
                                                ;helps init flavor-unmapped-instance-variables
  (:SELECT-METHOD-ORDER :TYO :STRING-OUT :LINE-OUT :TYI :TYI-NO-HANG :LISTEN)
  (:GETTABLE-INSTANCE-VARIABLES IO-BUFFER stream-rubout-handler displayer)
  (:INITABLE-INSTANCE-VARIABLES IO-BUFFER RUBOUT-HANDLER-BUFFER)
  (:SETTABLE-INSTANCE-VARIABLES OLD-TYPEAHEAD stream-rubout-handler displayer)
  (:INIT-KEYWORDS :ASYNCHRONOUS-CHARACTERS)
  (:DOCUMENTATION :MIXIN "Ordinary tv stream operations.
Gives all the meaningful stream operations for a display, such as :TYO, :TYI, :RUBOUT-HANDLER,
:STRING-OUT, etc.  Include this flavor someplace so that the window can be passed to functions
that take streams as arguments, and especially if *TERMINAL-IO* is going to be bound to the
window."))


(DEFMETHOD (STREAM-MIXIN :BEFORE :INIT) (INIT-PLIST)
  (SEND SELF :WHICH-OPERATIONS)         ;Pre-create this, certainly going to be used
  (UNLESS (TYPEP IO-BUFFER 'IO-BUFFER)
    (LET (SIZE INPUT-FUNCTION OUTPUT-FUNCTION)
      (IF (NUMBERP IO-BUFFER)
          (SETQ SIZE IO-BUFFER
                INPUT-FUNCTION NIL
                OUTPUT-FUNCTION 'KBD-DEFAULT-OUTPUT-FUNCTION)
        (SETQ SIZE (OR (FIRST IO-BUFFER) 100)
              INPUT-FUNCTION (SECOND IO-BUFFER)
              OUTPUT-FUNCTION (OR (THIRD IO-BUFFER) 'KBD-DEFAULT-OUTPUT-FUNCTION)))
      (SETQ IO-BUFFER (MAKE-IO-BUFFER SIZE INPUT-FUNCTION OUTPUT-FUNCTION))))
  (IF (GETL INIT-PLIST '(:ASYNCHRONOUS-CHARACTERS))
      (SETF (GETF (IO-BUFFER-PLIST IO-BUFFER) :ASYNCHRONOUS-CHARACTERS)
            (GET INIT-PLIST :ASYNCHRONOUS-CHARACTERS)))
  (UNLESS RUBOUT-HANDLER-BUFFER
    (SETQ RUBOUT-HANDLER-BUFFER (MAKE-RUBOUT-HANDLER-BUFFER))))

(DEFMETHOD (STREAM-MIXIN :ADD-ASYNCHRONOUS-CHARACTER) (CHARACTER FUNCTION &REST ARGS)
;character lossage
  (IF (CHARACTERP CHARACTER) (SETQ CHARACTER (CHAR-INT CHARACTER)))
  (CHECK-TYPE CHARACTER FIXNUM "a character")
  (CHECK-TYPE FUNCTION (SATISFIES FUNCTIONP) "a function")
  (LET ((PLIST (LOCF (IO-BUFFER-PLIST IO-BUFFER))))
    (PUSH (LIST* CHARACTER FUNCTION (COPYLIST ARGS))
          (GET PLIST :ASYNCHRONOUS-CHARACTERS))))

(DEFMETHOD (STREAM-MIXIN :ASYNCHRONOUS-CHARACTER-P) (CHARACTER)
;character lossage
  (IF (CHARACTERP CHARACTER) (SETQ CHARACTER (CHAR-INT CHARACTER)))
  (LET* ((PLIST (LOCF (IO-BUFFER-PLIST IO-BUFFER)))
         (ALIST (GET PLIST :ASYNCHRONOUS-CHARACTERS)))
    (ASSQ CHARACTER ALIST)))

(DEFMETHOD (STREAM-MIXIN :HANDLE-ASYNCHRONOUS-CHARACTER) (CHARACTER)
;character lossage
  (IF (CHARACTERP CHARACTER) (SETQ CHARACTER (CHAR-INT CHARACTER)))
  (LET* ((PLIST (LOCF (IO-BUFFER-PLIST IO-BUFFER)))
         (ALIST (GET PLIST :ASYNCHRONOUS-CHARACTERS))
         (TEM (ASSQ CHARACTER ALIST)))
    (WHEN TEM (APPLY (CADR TEM) (CAR TEM) SELF (CDDR TEM)))))

(DEFMETHOD (STREAM-MIXIN :REMOVE-ASYNCHRONOUS-CHARACTER) (CHARACTER)
;character lossage
  (IF (CHARACTERP CHARACTER) (SETQ CHARACTER (CHAR-INT CHARACTER)))
  (LET* ((PLIST (LOCF (IO-BUFFER-PLIST IO-BUFFER)))
         (ALIST (GET PLIST :ASYNCHRONOUS-CHARACTERS)))
    (SETF (GET PLIST :ASYNCHRONOUS-CHARACTERS)
          (DELQ (ASSQ CHARACTER ALIST) ALIST))))

(DEFMETHOD (STREAM-MIXIN :DIRECTION) () :BIDIRECTIONAL)

(DEFMETHOD (STREAM-MIXIN :BEFORE :SELECT) (&REST IGNORE)
  (KBD-CLEAR-SELECTED-IO-BUFFER))

(DEFMETHOD (STREAM-MIXIN :BEFORE :DESELECT) (&REST IGNORE)
  (KBD-CLEAR-SELECTED-IO-BUFFER))

(DEFMETHOD (STREAM-MIXIN :SET-IO-BUFFER) (NEW-BUFFER)
  (WITHOUT-INTERRUPTS
    (KBD-CLEAR-SELECTED-IO-BUFFER)
    (SETQ IO-BUFFER NEW-BUFFER)))

(DEFMETHOD (STREAM-MIXIN :PUSH-INPUT) (INPUT)
  (IF (STRINGP INPUT)
      (DO ((I (1- (STRING-LENGTH INPUT)) (1- I)))
          ((MINUSP I))
        (IO-BUFFER-PUSH IO-BUFFER (AREF INPUT I)))
    (IO-BUFFER-PUSH IO-BUFFER INPUT)))


(DEFMETHOD (STREAM-MIXIN :UNTYI) (CH)
  (IF (AND (eq rubout-handler self)
           ;; RUBOUT-HANDLER added as conjunct 6/1/83
           ;; to avoid lossage entering editor rubout handler
           ;; by typing (= 1 2) then stray ) while inside BREAK.
           ( 1 (RHB-SCAN-POINTER) (RHB-FILL-POINTER))
           (EQ CH (AREF RUBOUT-HANDLER-BUFFER (1- (RHB-SCAN-POINTER)))))
      (DECF (RHB-SCAN-POINTER))
    (IO-BUFFER-UNGET IO-BUFFER CH))
  CH)

(DEFMETHOD (STREAM-MIXIN :UNREAD-CHAR) (CH)
  (IF (CHARACTERP CH) (SETQ CH (CHAR-INT CH)))
  (SEND SELF :UNTYI CH))

(DEFMETHOD (STREAM-MIXIN :LISTEN) ()
  (NOT (AND ( (RHB-FILL-POINTER) (RHB-SCAN-POINTER))
            (IO-BUFFER-EMPTY-P IO-BUFFER)
            (WITHOUT-INTERRUPTS
              (IF (NEQ IO-BUFFER (KBD-GET-IO-BUFFER))
                  T
                (AND (KBD-HARDWARE-CHAR-AVAILABLE)
                     (KBD-PROCESS-MAIN-LOOP-INTERNAL))
                (IO-BUFFER-EMPTY-P KBD-IO-BUFFER))))))

(DEFMETHOD (STREAM-MIXIN :WAIT-FOR-INPUT-WITH-TIMEOUT) (TIMEOUT)
  (KBD-WAIT-FOR-INPUT-WITH-TIMEOUT IO-BUFFER TIMEOUT))

(DEFMETHOD (STREAM-MIXIN :CLEAR-INPUT) ()
  (SETF (RHB-FILL-POINTER) 0)
  (SETF (RHB-SCAN-POINTER) 0)
  (IO-BUFFER-CLEAR IO-BUFFER)
  (AND (EQ IO-BUFFER (KBD-GET-IO-BUFFER))
       (KBD-CLEAR-IO-BUFFER)))

(DEFMETHOD (STREAM-MIXIN :TYI) (&OPTIONAL IGNORE &AUX CH)
  (DO-FOREVER
    (SETQ CH (SEND SELF :ANY-TYI))
    (WHEN (NUMBERP CH)
      (RETURN CH))
    (WHEN (AND (CONSP CH)
               (EQ (CAR CH) :MOUSE-BUTTON)
               (MEMQ (CADR CH) '(#/MOUSE-3-1 #.(CHAR-INT #/MOUSE-3-1))))
      (MOUSE-CALL-SYSTEM-MENU))))

(DEFMETHOD (STREAM-MIXIN :READ-CHAR) (&OPTIONAL IGNORE IGNORE)
  (INT-CHAR (SEND SELF :TYI)))

(DEFMETHOD (STREAM-MIXIN :TYI-NO-HANG) (&OPTIONAL IGNORE &AUX CH)
  (DO-FOREVER
    (SETQ CH (SEND SELF :ANY-TYI-NO-HANG))
    (WHEN (OR (NULL CH)
              (NUMBERP CH))
      (RETURN CH))
    (WHEN (AND (CONSP CH)
               (EQ (CAR CH) :MOUSE-BUTTON)
               (MEMQ (CADR CH) '(#/MOUSE-3-1 #.(CHAR-INT #/MOUSE-3-1))))
      (MOUSE-CALL-SYSTEM-MENU))))

(DEFMETHOD (STREAM-MIXIN :READ-CHAR-NO-HANG) (&OPTIONAL IGNORE IGNORE)
  (INT-CHAR (SEND SELF :TYI-NO-HANG)))

(DEFMETHOD (STREAM-MIXIN :ANY-TYI) (&OPTIONAL IGNORE &AUX IDX)
  (COND ((> (RHB-FILL-POINTER) (SETQ IDX (RHB-SCAN-POINTER)))
         (SETF (RHB-SCAN-POINTER) (1+ IDX))
         (OR (AREF RUBOUT-HANDLER-BUFFER IDX)
             (FERROR "EOF on input from a window.")))
        ((neq rubout-handler self)
;        (SETF (RHB-SCAN-POINTER) (RHB-FILL-POINTER))
         (LET ((CHAR
                 (COND ((KBD-IO-BUFFER-GET IO-BUFFER T))
                       (T
                        (SEND SELF :NOTICE :INPUT-WAIT)
                        (KBD-IO-BUFFER-GET IO-BUFFER)))))
           (IF (AND (eq rubout-handler-inside self)
                    (EQ OLD-TYPEAHEAD T)
                    (CONSP CHAR)
                    (NEQ (CAR CHAR) 'REDISPLAY-RUBOUT-HANDLER))
               ;; If inside the rubout handler in a :PREEMPTABLE-READ
               ;; and we just got a blip that isn't intended for the rubout handler.
               (PROGN
                 (MULTIPLE-VALUE-BIND (STRING INDEX)
                     (SEND SELF :SAVE-RUBOUT-HANDLER-BUFFER)
                   (SETQ OLD-TYPEAHEAD (LIST STRING INDEX)))
                 ;; Save the text, rub it all out, and unread the blip.
                 ;; The :FULL-RUBOUT option will cause the RH to return to the caller
                 ;; who will then read the blip.
                 (SEND SELF :UNTYI CHAR)
                 (CHAR-INT #/CLEAR))
             CHAR)))
        (T
         (OR (FUNCALL (or stream-rubout-handler stream-mixin-default-rubout-handler))
             (FERROR "EOF on input from a window.")))))

(DEFMETHOD (STREAM-MIXIN :ANY-READ-CHAR) (&OPTIONAL IGNORE IGNORE &AUX CH)
  (SETQ CH (SEND SELF :TYI-NO-HANG))
  (IF (FIXNUMP CH) (INT-CHAR CH) CH))

(DEFMETHOD (STREAM-MIXIN :ANY-TYI-NO-HANG) (&OPTIONAL IGNORE)
  (if (> (RHB-FILL-POINTER) (RHB-SCAN-POINTER))
      (send self :any-tyi))
  (if (neq rubout-handler self)
      (KBD-IO-BUFFER-GET IO-BUFFER T)
    (FERROR "~S from inside a rubout handler." :ANY-TYI-NO-HANG)))

(DEFMETHOD (STREAM-MIXIN :ANY-READ-CHAR-NO-HANG) (&OPTIONAL IGNORE IGNORE &AUX CH)
  (SETQ CH (SEND SELF :ANY-TYI-NO-HANG))
  (IF (FIXNUMP CH) (INT-CHAR CH) CH))

;;; For things only prepared to deal with fixnums
(DEFMETHOD (STREAM-MIXIN :MOUSE-OR-KBD-TYI) (&AUX CH)
  (DO-FOREVER
    (SETQ CH (SEND SELF :ANY-TYI))
    (WHEN (NUMBERP CH)
      (RETURN (VALUES CH CH)))
    (WHEN (AND (CONSP CH) (EQ (CAR CH) :MOUSE-BUTTON))
      (RETURN (VALUES (SECOND CH) CH)))))

(DEFMETHOD (STREAM-MIXIN :MOUSE-OR-KBD-TYI-NO-HANG) (&AUX CH)
  (DO-FOREVER
    (SETQ CH (SEND SELF :ANY-TYI-NO-HANG))
    (WHEN (OR (NULL ch) (NUMBERP CH))
      (RETURN (VALUES CH CH)))
    (WHEN (AND (CONSP CH) (EQ (CAR CH) :MOUSE-BUTTON))
      (RETURN (VALUES (SECOND CH) CH)))))

(DEFMETHOD (STREAM-MIXIN :LIST-TYI) (&AUX CH)
  "Only return lists"
  (DO-FOREVER
    (SETQ CH (SEND SELF :ANY-TYI))
    (AND (CONSP CH) (RETURN CH))))

;;; Return a circular buffer array describing the last however many input characters.
;;; The (array-leader array 1) points at the last slot stored into.
(DEFMETHOD (STREAM-MIXIN :PLAYBACK) ()
  (IO-BUFFER-RECORD IO-BUFFER))

(DEFMETHOD (STREAM-MIXIN :FORCE-KBD-INPUT) (CH-OR-STRING)
  (IF (STRINGP CH-OR-STRING)
      (DOTIMES (N (LENGTH CH-OR-STRING))
        (IO-BUFFER-PUT IO-BUFFER (AREF CH-OR-STRING N)))
    (IO-BUFFER-PUT IO-BUFFER CH-OR-STRING)))    ;all of the old cases.

(DEFFLAVOR LIST-TYI-MIXIN () ()
  (:DOCUMENTATION :MIXIN "Makes :TYI discard non-keyboard input."))

(DEFFLAVOR ANY-TYI-MIXIN () ()
  (:DOCUMENTATION :MIXIN "Obsolete flavor"))

(DEFFLAVOR PREEMPTABLE-READ-ANY-TYI-MIXIN () ())

(DEFVAR RUBOUT-HANDLER-STARTING-X :UNBOUND
  "Within rubout handler, X position of beginning of input.")
(DEFVAR RUBOUT-HANDLER-STARTING-Y :UNBOUND
  "Within rubout handler, Y position of beginning of input.")
(DEFVAR RUBOUT-HANDLER-RE-ECHO-FLAG :UNBOUND
  "Within rubout handler, T when there are error messages in the middle of the input.
Set to NIL when the input is reprinted and they are gone.")
(DEFVAR RUBOUT-HANDLER-INSIDE NIL
  "Non-NIL while inside the rubout handler.")
(DEFVAR RUBOUT-HANDLER-ACTIVATION-CHARACTER NIL
  "The character or blip that is activating this invocation of :RUBOUT-HANDLER.")

(DEFVAR PROMPT-STARTING-X :UNBOUND
  "Within rubout handler, X position of beginning of printed prompt string.")
(DEFVAR PROMPT-STARTING-Y :UNBOUND
  "Within rubout handler, Y position of beginning of printed prompt string.")

(defmethod (stream-mixin :rubout-handler) (options function &rest args)
  (declare (arglist rubout-handler-options function &rest args))
  (if (and (eq rubout-handler self) (not (cdr (assq :nonrecursive options))))
      (let ((rubout-handler-options (append options rubout-handler-options)))
        (apply function args))
    (let ((rubout-handler-options options))
      (if ( (rhb-fill-pointer) (rhb-scan-pointer))
          (setf (rhb-fill-pointer) 0)
        (copy-array-portion rubout-handler-buffer (rhb-scan-pointer) (rhb-fill-pointer)
                            rubout-handler-buffer 0 (array-length rubout-handler-buffer))
        (if (numberp (rhb-typein-pointer))
            (decf (rhb-typein-pointer) (rhb-scan-pointer)))
        (decf (rhb-fill-pointer) (rhb-scan-pointer)))
      (setf (rhb-scan-pointer) 0 (rhb-status) :initial-entry)
      (catch 'return-from-rubout-handler
        (let (prompt-starting-x prompt-starting-y
              rubout-handler-starting-x rubout-handler-starting-y
              (rubout-handler self)
              (rubout-handler-inside self)
              (rubout-handler-re-echo-flag nil)
              (rubout-handler-activation-character nil))
          (multiple-value (prompt-starting-x prompt-starting-y) (send self :read-cursorpos))
          (setq rubout-handler-starting-x prompt-starting-x
                rubout-handler-starting-y prompt-starting-y)
          (do-forever
            (setq rubout-handler-re-echo-flag nil)
            (catch 'rubout-handler                      ;Throw here when rubbing out
              (condition-case (error)
                  (return
                   (multiple-value-prog1
                     (apply function args)              ;Call READ or whatever.
                     (setf (rhb-fill-pointer) (rhb-scan-pointer))
                     (and (rhb-typein-pointer)
                          (> (rhb-typein-pointer) (rhb-fill-pointer))
                          (setf (rhb-typein-pointer) (rhb-fill-pointer)))))
                (sys:parse-error
                 (send self :fresh-line)
                 (princ ">>ERROR: " self)
                 (send error :report self)
                 (send self :fresh-line)
                 (setq rubout-handler-re-echo-flag t)
                 (do-forever (send self :tyi)))))       ;If error, force user to rub out
            ;;Maybe return when user rubs all the way back
            (and (zerop (rhb-fill-pointer))
                 (let ((full-rubout-option (assq :full-rubout rubout-handler-options)))
                   (when full-rubout-option
                     ;; Get rid of the prompt, if any.
                     (send self :clear-between-cursorposes
                                prompt-starting-x prompt-starting-y
                                (- cursor-x left-margin-size) (- cursor-y top-margin-size))
                     (send self :set-cursorpos prompt-starting-x prompt-starting-y)
                     (return (values nil (cadr full-rubout-option))))))))))))

(defmethod (stream-mixin :rescanning-p) ()
  (or (< (rhb-scan-pointer) (rhb-fill-pointer))
      rubout-handler-activation-character))

(defmethod (stream-mixin :force-rescan) ()
  (setf (rhb-scan-pointer) 0)
  (throw 'rubout-handler t))

(defmethod (stream-mixin :read-bp) ()
  (rhb-scan-pointer))

;;; Foo.
(defmethod (stream-mixin :replace-input) (n string &optional (start 0) end)
  (declare (ignore n string start end))
  (ferror "Foo. I haven't written this yet.")
  )
;;; Foo. This is hair implemented by Brand S which seems to be a real crock.
(defmethod (stream-mixin :start-typeout) (type &optional spacing)
  type spacing
  ;(ferror "Foo. I haven't written this yet.")
  )
(defmethod (stream-mixin :finish-typeout) (&optional spacing erase-p)
  spacing erase-p
  ;(ferror "Foo. I haven't written this yet.")
  )


(DEFMETHOD (STREAM-MIXIN :PREEMPTABLE-READ) (OPTIONS FUN &REST ARGS)
  (DO ((TYPEAHEAD OLD-TYPEAHEAD NIL)
       (RESULT) (FLAG))
      (())
    (SETQ OLD-TYPEAHEAD T)
    (UNWIND-PROTECT
      (MULTIPLE-VALUE (RESULT FLAG)
        (with-stack-list (initial-input :initial-input
                                        (if (consp typeahead) (car typeahead)))
          (with-stack-list (initial-input-pointer :initial-input-pointer
                                          (if (consp typeahead) (cadr typeahead)))
            (with-stack-list* (options initial-input
                                       initial-input-pointer
                                       '((:full-rubout :full-rubout))
                                       options)
              (unless (consp typeahead) (setq options (cddr options)))
              (lexpr-send self :rubout-handler options FUN ARGS)))))
      (AND (EQ OLD-TYPEAHEAD T)
           (SETQ OLD-TYPEAHEAD NIL)))
    (AND (NEQ FLAG :FULL-RUBOUT)
         (RETURN (VALUES RESULT NIL)))
    ;; Determine whether a mouse character caused the full-rubout
    (SETQ RESULT (SEND SELF :ANY-TYI-NO-HANG))
    (COND (RESULT
           (OR (NUMBERP RESULT)
               (RETURN (VALUES RESULT :MOUSE-CHAR)))
           (SEND SELF :UNTYI RESULT)))
    (AND (SETQ FLAG (CADR (ASSQ :FULL-RUBOUT OPTIONS)))
         (RETURN (VALUES NIL FLAG)))
    ;; Presumably after this point, the user didn't call us with :FULL-RUBOUT
    ;; option, so we should retry. We have to fix up the notion of :PROMPT
    ;; and :REPROMPT first though.
    (LET ((PROMPT (ASSQ :PROMPT OPTIONS)))
      (WHEN PROMPT
        (SETQ OPTIONS (REMQ PROMPT OPTIONS))
        ;This next condition may be unnecessary, but just in case. --kmp
        (UNLESS (NOT (ASSQ :REPROMPT OPTIONS))
          ;; make fake reprompt info. our old prompt should still
          ;; be there --kmp
          (PUSH `(:REPROMPT . ,(CDR PROMPT)) OPTIONS))))))

;;; Give a single character, or do rubout processing, throws to RUBOUT-HANDLER on editing.
(defun default-rubout-handler ()
  (declare (:self-flavor stream-mixin))
  (setf (rhb-typein-pointer) nil)               ;Mark that old rubout handler is in use.
  (when (= (rhb-scan-pointer) most-positive-fixnum)
    (setf (rhb-scan-pointer) 0)
    (throw 'rubout-handler t))
  (let ((status (rhb-status))
        (rubbed-out-some nil)
        (rubout-handler nil))
    (setf (rhb-status) nil)
    (when (memq status '(:restored :initial-entry))
      ;;Prompt if desired
      (let ((prompt-option (assq :prompt rubout-handler-options)))
        (when prompt-option
          (rubout-handler-prompt (cadr prompt-option) self nil)))
      (multiple-value (rubout-handler-starting-x rubout-handler-starting-y)
        (send self :read-cursorpos))
      ;; Output any "typeahead"
      (when (plusp (rhb-fill-pointer))
        (send self :string-out rubout-handler-buffer))
      ;;no point looking for :initial-input-pointer since this rh can't do anything with it
      (let ((initial-input (cadr (assq :initial-input rubout-handler-options))))
        (when initial-input
          (string-nconc rubout-handler-buffer initial-input))))
    (or (prog1 rubout-handler-activation-character
               (setq rubout-handler-activation-character nil))
        (do ((editing-command (cdr (assq :editing-command rubout-handler-options)))
             (do-not-echo (cdr (assq :do-not-echo rubout-handler-options)))
             (pass-through (cdr (assq :pass-through rubout-handler-options)))
             (command-handler
               (assq :command rubout-handler-options))
             (preemptable (assq :preemptable rubout-handler-options))
             (activation-handler
               (assq :activation rubout-handler-options))
             ch len)
            (nil)
          (setq ch (send self :any-tyi))
          (cond ((eq (car-safe ch) 'redisplay-rubout-handler)
                 (send self :set-cursorpos prompt-starting-x prompt-starting-y)
                 (send self :clear-rest-of-line)
                 (and (setq len (or (assq :reprompt rubout-handler-options)
                                    (assq :prompt rubout-handler-options)))
                      (rubout-handler-prompt (cadr len) self ch))
                 (multiple-value (rubout-handler-starting-x rubout-handler-starting-y)
                   (send self :read-cursorpos))
                 (send self :string-out rubout-handler-buffer))
                ((consp ch)
                 (when preemptable
                   (setf (rhb-scan-pointer) 0)
                   (throw 'return-from-rubout-handler
                          (values ch (cadr preemptable)))))
                ((and command-handler
                      (apply (cadr command-handler) ch (cddr command-handler)))
                 (setf (rhb-scan-pointer) 0)
                 (throw 'return-from-rubout-handler
                         (values
                           `(:command ,ch 1)
                           :command)))
                ;; Don't touch this character, just return it to caller.
                ((or (memq ch editing-command)
                     (si:assq-careful ch editing-command))
                 ;; Cause rubout handler rescan next time the user does :TYI.
                 (if rubbed-out-some (setf (rhb-scan-pointer) most-positive-fixnum))
                 (return ch))
                ;; Is it an editing character?
                ((and (not (or (memq ch do-not-echo)
                               (and activation-handler
                                    (apply (cadr activation-handler) ch (cddr activation-handler)))))
                      (or (ldb-test %%kbd-control-meta ch)
                          (and (memq ch '(#/Rubout #/Clear-input #/Clear-screen #/Delete))
                               (not (memq ch pass-through)))))
                 (cond ((memq ch '(#/Clear-screen #/Delete))    ;Retype buffered input
                        (send self :tyo ch)             ;Echo it
                        (if (= ch #/Clear-screen) (send self :clear-window)
                          (send self :tyo #/Newline))
                        (multiple-value (prompt-starting-x prompt-starting-y)
                          (send self :read-cursorpos))
                        (and (setq len (or (assq :reprompt rubout-handler-options)
                                           (assq :prompt rubout-handler-options)))
                             (rubout-handler-prompt (cadr len) self ch))
                        (multiple-value (rubout-handler-starting-x rubout-handler-starting-y)
                          (send self :read-cursorpos))
                        (send self :string-out rubout-handler-buffer))
                       ((memq ch '(#/Rubout #/M-rubout #/Clear-input)) ;Delete some characters
                        (cond ((not (zerop (setq len (rhb-fill-pointer))))
                               (setf (rhb-fill-pointer)
                                     (setq len (selectq ch
                                                 (#/Rubout (1- len))
                                                 (#/M-rubout (string-backward-word
                                                               rubout-handler-buffer len))
                                                 (#/Clear-input 0))))
                               (setf rubbed-out-some t
                                     (rhb-status) :rubout)
                               (multiple-value-bind (x y)
                                   (send self :compute-motion rubout-handler-buffer 0 len
                                                 rubout-handler-starting-x rubout-handler-starting-y)
                                 (if rubout-handler-re-echo-flag
                                     (setq x rubout-handler-starting-x y rubout-handler-starting-y))
                                 (multiple-value-bind (cx cy) (send self :read-cursorpos)
                                   (send self :clear-between-cursorposes x y cx cy))
                                 (send self :set-cursorpos x y)
                                 (and rubout-handler-re-echo-flag
                                      (send self :string-out rubout-handler-buffer))))))
                       (t (beep)))                              ;Undefined editing character
                 (cond ((and (zerop (rhb-fill-pointer))
                             (assq :full-rubout rubout-handler-options))
                        (setf (rhb-scan-pointer) 0)
                        (throw 'rubout-handler t))))
                (t
                 ;; It's a self-inserting character.
                 ;; If this is first character typed in, re-get starting cursorpos since while
                 ;; waiting for input a notification may have been typed out.
                 (and (zerop (rhb-fill-pointer))
                      (multiple-value (rubout-handler-starting-x rubout-handler-starting-y)
                        (send self :read-cursorpos)))
                 (cond ((memq ch do-not-echo)
                        (setq rubout-handler-activation-character ch))
                       ((and activation-handler
                             (apply (cadr activation-handler) ch (cddr activation-handler)))
                        (setq ch `(:activation ,ch 1))
                        (setq rubout-handler-activation-character ch))
                       (t
                        (send self :tyo ch)
                        (array-push-extend rubout-handler-buffer ch)))
                 (cond (rubbed-out-some
                        (setf (rhb-scan-pointer) 0)
                        (throw 'rubout-handler t))
                       (t
                        (setf (rhb-scan-pointer) (rhb-fill-pointer))
                        (setq rubout-handler-activation-character nil)
                        (return ch)))))))))

;;; Use ZWEI's syntax table if ZWEI is around...
(DEFUN STRING-BACKWARD-WORD (STRING INDEX &AUX ALPHA-P-FCN)
  (SETQ ALPHA-P-FCN
        (IF (BOUNDP 'ZWEI:*WORD-SYNTAX-TABLE*)
            #'(LAMBDA (X) (EQ (ZWEI:CHAR-SYNTAX X ZWEI:*WORD-SYNTAX-TABLE*)
                              ZWEI:WORD-ALPHABETIC))
          'ALPHA-CHAR-P))
  (DO ((I (1- INDEX) (1- I))
       (INSIDE-WORD NIL))
      ((MINUSP I) 0)
    (IF (FUNCALL ALPHA-P-FCN (AREF STRING I))
        (SETQ INSIDE-WORD T)
      (AND INSIDE-WORD (RETURN (1+ I))))))

(DEFUN RUBOUT-HANDLER-PROMPT (PROMPT-OPTION STREAM CH)
  (LET ((RUBOUT-HANDLER NIL))   ;In case of **more**
    (IF (STRINGP PROMPT-OPTION)
        (FUNCALL STREAM :STRING-OUT PROMPT-OPTION)
      (FUNCALL PROMPT-OPTION STREAM CH))))

(defmethod (stream-mixin :save-rubout-handler-buffer) ()
  (when (eq rubout-handler-inside self)
    ;; Give rubout handler function a chance to put its internal data
    ;; into RUBOUT-HANDLER-BUFFER where we look for it.
; not patched in 98.
    (let ((prop (get (or stream-rubout-handler
                         stream-mixin-default-rubout-handler)
                     'save-rubout-handler-buffer)))
      (when prop (funcall prop self)))
    (values (copy-seq rubout-handler-buffer) (rhb-typein-pointer))))

(defmethod (stream-mixin :restore-rubout-handler-buffer) (string &optional pointer)
  (let ((length (array-active-length string)))
    (or ( (array-length rubout-handler-buffer) length)
        (adjust-array-size rubout-handler-buffer length))
    (copy-array-contents string rubout-handler-buffer)
    (setf (rhb-fill-pointer) length))
  (setf (rhb-typein-pointer) pointer)
  (send self :refresh-rubout-handler)
  (setf (rhb-scan-pointer) 0)
  ;(setf (rhb-status) :restored)
  (throw 'rubout-handler t))

(defmethod (stream-mixin :refresh-rubout-handler) (&optional discard-last-character)
  (if discard-last-character
      (setf (rhb-fill-pointer) (max 0 (1- (rhb-fill-pointer)))))
  (if (rhb-typein-pointer)
      (setf (rhb-typein-pointer)
            (min (rhb-typein-pointer) (rhb-fill-pointer))))
  (send self :fresh-line)
  (let ((prompt (or (assq :reprompt rubout-handler-options)
                    (assq :prompt rubout-handler-options))))
    (when prompt (rubout-handler-prompt (cadr prompt) self #/Delete)))
  (multiple-value (rubout-handler-starting-x rubout-handler-starting-y)
    (send self :read-cursorpos))
  (send self :string-out rubout-handler-buffer))

;;; Stream operations which all streams are required to support or ignore
;;; I'm afraid these will appear in the :WHICH-OPERATIONS even though they
;;; aren't "really supported"

;;; These 3 are ignored since we don't have buffered output
(DEFMETHOD (STREAM-MIXIN :CLEAR-OUTPUT) ()
  NIL)

(DEFMETHOD (STREAM-MIXIN :FORCE-OUTPUT) ()
  NIL)

(DEFMETHOD (STREAM-MIXIN :FINISH) ()
  NIL)

(DEFMETHOD (STREAM-MIXIN :CLOSE) (&OPTIONAL IGNORE)
  NIL)

(DEFMETHOD (STREAM-MIXIN :LINE-IN) (&OPTIONAL LEADER)
  (STREAM-DEFAULT-HANDLER SELF :LINE-IN LEADER NIL))

(DEFMETHOD (STREAM-MIXIN :STRING-IN) (EOF &REST REST)
  (DECLARE (ARGLIST EOF STRING &OPTIONAL START END))
  (STREAM-DEFAULT-HANDLER SELF :STRING-IN EOF REST))

(DEFMETHOD (STREAM-MIXIN :STRING-LINE-IN) (EOF &REST REST)
  (DECLARE (ARGLIST EOF STRING &OPTIONAL START END))
  (STREAM-DEFAULT-HANDLER SELF :STRING-LINE-IN EOF REST))


(DEFFLAVOR LINE-TRUNCATING-MIXIN () ()
  (:REQUIRED-FLAVORS STREAM-MIXIN)
  (:DOCUMENTATION :MIXIN "Causes stream output functions to truncate if the
SHEET-TRUNCATE-LINE-OUT-FLAG in the window is set."))

(DEFWRAPPER (LINE-TRUNCATING-MIXIN :TYO) (IGNORE . BODY)
  `(CATCH 'LINE-OVERFLOW
     . ,BODY))

(DEFMETHOD (LINE-TRUNCATING-MIXIN :BEFORE :END-OF-LINE-EXCEPTION) ()
  (OR (ZEROP (SHEET-TRUNCATE-LINE-OUT-FLAG))
      (THROW 'LINE-OVERFLOW T)))

(DEFWHOPPER (LINE-TRUNCATING-MIXIN :STRING-OUT) (STRING &OPTIONAL (START 0) END)
  (OR END (SETQ END (STRING-LENGTH STRING)))
  (DO ((I START (1+ CR-IDX))
       (CR-IDX))
      (( I END))
    (SETQ CR-IDX (POSITION #/NEWLINE STRING :START I :END END))
    (CATCH 'LINE-OVERFLOW
      (CONTINUE-WHOPPER STRING I (OR CR-IDX END)))
    (OR CR-IDX (RETURN NIL))
    (SHEET-CRLF SELF)))

(DEFFLAVOR TRUNCATING-WINDOW () (LINE-TRUNCATING-MIXIN WINDOW)
  (:DEFAULT-INIT-PLIST :TRUNCATE-LINE-OUT-FLAG 1)
  (:DOCUMENTATION :COMBINATION "A window that truncates line of output."))

(DEFFLAVOR AUTOEXPOSING-MORE-MIXIN () ()
  (:REQUIRED-FLAVORS WINDOW)
  (:DOCUMENTATION :MIXIN
   "Makes a window expose itself if output on it stops at a **MORE**."))

(DEFMETHOD (AUTOEXPOSING-MORE-MIXIN :BEFORE :MORE-EXCEPTION) ()
  (SEND SELF :EXPOSE))
